home *** CD-ROM | disk | FTP | other *** search
/ Celestin Apprentice 7 / Apprentice-Release7.iso / Source Code / C / Applications / Moscow ML 1.42 / src / mosmllib / FileSys.mlp < prev    next >
Encoding:
Text File  |  1997-08-18  |  8.4 KB  |  273 lines  |  [TEXT/R*ch]
  1. (* FileSys -- 1995-06-16, 1995-09-25, 1996-05-01, 1996-10-13 *)
  2.  
  3. local 
  4.  
  5.     (* The type of directory structures, as handled by the OS: *)
  6.     prim_type dirstruct_; 
  7.  
  8.     (* Primitives from runtime/sys.c -- raise Io on error *)
  9.     prim_val chdir_  : string -> unit            = 1 "sys_chdir";
  10.     prim_val remove_ : string -> unit            = 1 "sys_remove";
  11.     prim_val rename_ : string -> string -> unit  = 2 "sys_rename";
  12.  
  13.     (* Primitives from runtime/mosml.c -- raise Fail on error *)
  14.     prim_val access_    : string -> int -> bool  = 2 "sml_access";
  15.     prim_val getdir_    : unit -> string         = 1 "sml_getdir"; 
  16.     prim_val isdir_     : string -> bool         = 1 "sml_isdir";
  17.     prim_val mkdir_     : string -> unit         = 1 "sml_mkdir";
  18.     prim_val tmpnam_    : unit -> string         = 1 "sml_tmpnam";
  19.     prim_val modtime_   : string -> real         = 1 "sml_modtime";
  20.     prim_val rmdir_     : string -> unit         = 1 "sml_rmdir";
  21.     prim_val settime_   : string -> real -> unit = 2 "sml_settime";
  22.     prim_val filesize_  : string -> int          = 1 "sml_filesize";
  23.  
  24.     prim_val opendir_   : string -> dirstruct_   = 1 "sml_opendir";
  25.     prim_val readdir_   : dirstruct_ -> string   = 1 "sml_readdir";
  26.     prim_val rewinddir_ : dirstruct_ -> unit     = 1 "sml_rewinddir";
  27.     prim_val closedir_  : dirstruct_ -> unit     = 1 "sml_closedir";
  28.  
  29.     fun formatErr mlOp (SOME operand) reason =
  30.     mlOp ^ " failed on `" ^ operand ^ "': " ^ reason
  31.       | formatErr mlOp NONE reason =
  32.     mlOp ^ " failed: " ^ reason
  33.  
  34.     (* Raise SysErr from ML function *)
  35.     fun raiseSysML mlOp operand reason =
  36.     raise SysErr (formatErr mlOp operand reason, NONE)
  37.  
  38.     (* Raise SysErr with OS specific explanation if errno <> 0 *)
  39.     fun raiseSys mlOp operand reason =
  40.     let prim_val errno_    : unit -> int        = 1 "sml_errno";
  41.         prim_val errormsg_ : int -> string      = 1 "sml_errormsg"; 
  42.         prim_val mkerrno_  : int -> OS.syserror = 1 "identity";
  43.             val errno = errno_ ()
  44.     in
  45.         if errno = 0 then raiseSysML mlOp operand reason
  46.         else raise SysErr 
  47.         (formatErr mlOp operand (errormsg_ errno), 
  48.          SOME (mkerrno_ errno))
  49.     end
  50. in
  51.  
  52.     type dirstream  = dirstruct_ option ref;
  53.     datatype access = A_READ | A_WRITE | A_EXEC;
  54.  
  55.     fun access (path, perm) =
  56.     let fun mem p = if List.exists (fn q => p=q) perm then 1 else 0
  57.         val permcode = mem A_READ + 2 * mem A_WRITE + 4 * mem A_EXEC
  58.     in 
  59.         (access_ path permcode) 
  60.         handle Fail s => raiseSys "access" (SOME path) s
  61.     end;
  62.  
  63.     fun getDir () =
  64.     (getdir_ ()) 
  65.     handle Fail s => raiseSys "getDir" NONE s;
  66.  
  67.     fun isDir p = 
  68.     (isdir_ p) handle Fail s => raiseSys "isDir" (SOME p) s;
  69.  
  70.     fun mkDir p = 
  71.     (mkdir_ p) handle Fail s => raiseSys "mkDir" (SOME p) s;
  72.  
  73. #ifdef unix
  74.     fun chDir p =
  75.     (chdir_ p)
  76.     handle SysErr _ => raiseSys "chDir" (SOME p) "chdir";
  77.  
  78.     fun mosmlFullPath p = 
  79.     let prim_val islink_   : string -> bool   = 1 "sml_islink"
  80.         prim_val readlink_ : string -> string = 1 "sml_readlink"
  81.             val links = ref 0
  82.         fun incrlink () = 
  83.         if !links < 30 then links := !links + 1
  84.         else raise Fail "Too many symbolic links encountered"
  85.         open Path
  86.         fun expand p = 
  87.         let val {vol, arcs, isAbs} = Path.fromString p
  88.             val root = if isAbs then vol ^ "/" else vol
  89.         in mkCanonical (List.foldl followlink root arcs) end
  90.         and followlink (a, p) = 
  91.         let val file = concat(p, a)
  92.         in
  93.             if islink_ file then 
  94.             (incrlink(); 
  95.              expand(mkAbsolute(readlink_ file, p)))
  96.             else
  97.             file
  98.         end
  99.     in 
  100.         (expand(mkAbsolute(p, getDir())))
  101.         handle Fail s => raiseSys "fullPath" (SOME p) s
  102.     end;
  103.  
  104.     fun fullPath p =
  105.     let prim_val realpath_ : string -> string = 1 "sml_realpath"
  106.     in 
  107.         (realpath_ p) 
  108.         handle Fail "realpath not supported" => mosmlFullPath p
  109.          | Fail s => raiseSys "fullPath" (SOME p) s 
  110.     end;
  111.     
  112.     fun isLink p =
  113.     let prim_val islink_ : string -> bool = 1 "sml_islink"
  114.         in (islink_ p) handle Fail s => raiseSys "isLink" (SOME p) s end;
  115.  
  116.     fun readLink p =
  117.     let prim_val readlink_ : string -> string = 1 "sml_readlink"
  118.     in (readlink_ p) handle Fail s => raiseSys "readLink" (SOME p) s end;
  119.  
  120.     type file_id = real;  (* Namely, 2^17 * device id  + inode number *)
  121.  
  122.     fun fileId p : file_id =
  123.     let prim_val devinode_ : string -> real = 1 "sml_devinode"
  124.     in (devinode_ p) handle Fail s => raiseSys "fileId" (SOME p) s end;
  125.  
  126.     fun hash (fid : file_id) = 
  127.     let prim_val hash_param : int -> int -> 'a -> word
  128.                         = 3 "hash_univ_param";
  129.     in hash_param 50 500 fid end;
  130.  
  131.     fun compare (fid1 : file_id, fid2) =
  132.     if fid1 < fid2 then LESS
  133.     else if fid1 > fid2 then GREATER
  134.     else EQUAL    
  135. #endif
  136. #ifdef msdos
  137.     fun chDir p =
  138.     let prim_val setdisk_ : int -> unit = 1 "sml_setdisk"
  139.         fun failvol () = raiseSys "chDir" (SOME p) "Illegal volume name"
  140.         fun volno c =        (* A = 0, B = 1, ... *)
  141.         if Char.isAlpha c then (Char.ord c - 65) mod 32
  142.         else failvol ()
  143.         val vol = Path.getVolume p
  144.     in 
  145.         if vol = "" then ()
  146.         else (setdisk_ (volno (String.sub(vol, 0))))
  147.          handle Fail s => failvol ();
  148.         (chdir_ p) handle SysErr _ => raiseSys "chDir" (SOME p) "chdir"
  149.     end;
  150.  
  151.     fun fullPath p =
  152.     let open Path 
  153.         val realp = mkCanonical(mkAbsolute(p, getDir()))
  154.     in 
  155.         if access (realp, []) then realp 
  156.         else raise raiseSys "fullPath" (SOME realp) 
  157.                         "No such file or directory"
  158.     end
  159.  
  160.     fun isLink p =
  161.     if access_ p 0 then false 
  162.     else raiseSys "isLink" (SOME p) "No such file";
  163.  
  164.     fun readLink p =
  165.     raiseSys "readLink" (SOME p) "No symlinks";
  166.  
  167.     type file_id = string * word; (* The full path and the hash value *)
  168.  
  169.     fun fileId p : file_id =
  170.     let prim_val hash_param : int -> int -> 'a -> word
  171.                         = 3 "hash_univ_param"
  172.             fun stringToLower s = CharVector.tabulate(size s, 
  173.                       fn i => Char.toLower(CharVector.sub(s, i)));
  174.             val p' = stringToLower (fullPath p) 
  175.              handle SysErr(s, _) => raiseSys "fileId" (SOME p) s 
  176.     in (p', hash_param 50 500 p') end
  177.  
  178.     fun hash ((_, hashval) : file_id) = hashval
  179.  
  180.     fun compare ((p1, h1) : file_id, (p2, h2)) =
  181.     if h1 = h2 then String.compare(p1, p2)
  182.     else if h1 < h2 then LESS
  183.     else GREATER
  184. #endif
  185. #ifdef macintosh
  186.     fun chDir p =
  187.     (chdir_ p)
  188.     handle SysErr _ => raiseSys "chDir" (SOME p) "chdir";
  189.  
  190.     fun fullPath p =
  191.     let prim_val realpath_ : string -> string = 1 "sml_realpath"
  192.     in 
  193.         (realpath_ p) 
  194.         handle Fail s => raiseSys "fullPath" (SOME p) s 
  195.     end;
  196.  
  197.     fun isLink p =
  198.     let prim_val islink_ : string -> bool = 1 "sml_islink"
  199.         in (islink_ p) handle Fail s => raiseSys "isLink" (SOME p) s end;
  200.  
  201.     fun readLink p =
  202.     let prim_val readlink_ : string -> string = 1 "sml_readlink"
  203.     in (readlink_ p) handle Fail s => raiseSys "readLink" (SOME p) s end;
  204.  
  205.     type file_id = real;  (* Namely, 2^17 * device id  + inode number *)
  206.  
  207.     fun fileId p : file_id =
  208.     let prim_val devinode_ : string -> real = 1 "sml_devinode"
  209.     in (devinode_ p) handle Fail s => raiseSys "fileId" (SOME p) s end;
  210.  
  211.     fun hash (fid : file_id) = 
  212.     let prim_val hash_param : int -> int -> 'a -> word
  213.                         = 3 "hash_univ_param";
  214.     in hash_param 50 500 fid end;
  215.  
  216.     fun compare (fid1 : file_id, fid2) =
  217.     if fid1 < fid2 then LESS
  218.     else if fid1 > fid2 then GREATER
  219.     else EQUAL    
  220. #endif
  221.  
  222.     fun realPath p =
  223.     if Path.isAbsolute p then fullPath p
  224.     else Path.mkRelative(fullPath p, getDir());
  225.  
  226.     fun rmDir p = 
  227.     (rmdir_ p) handle Fail s => raiseSys "rmDir" (SOME p) s;
  228.  
  229.     fun tmpName () =
  230.     (tmpnam_ ())
  231.     handle Fail s => raiseSys "tmpName" NONE s
  232.  
  233.     fun modTime p = 
  234.     (Time.fromReal (modtime_ p))
  235.     handle Fail s => raiseSys "modTime" (SOME p) s;
  236.  
  237.     fun fileSize p =
  238.     (filesize_ p) 
  239.     handle Fail s => raiseSys "fileSize" (SOME p) s;
  240.  
  241.     fun remove p = 
  242.     (remove_ p)
  243.     handle SysErr _ => raiseSys "remove" (SOME p) "unlink";
  244.  
  245.     fun rename {old, new} = 
  246.     (rename_ old new) 
  247.     handle SysErr _ => raiseSys "rename" (SOME old) "rename";
  248.  
  249.     fun setTime (path, time) =
  250.     let val tsec = 
  251.         Time.toReal (case time of NONE => Time.now() | SOME t => t)
  252.     in
  253.         (settime_ path tsec) 
  254.         handle Fail s => raiseSys "setTime" (SOME path) s
  255.     end;
  256.  
  257.     fun openDir path = 
  258.     (ref (SOME (opendir_ path)))
  259.     handle Fail s => raiseSys "openDir" (SOME path) s;
  260.  
  261.     fun readDir (ref NONE) = 
  262.     raiseSysML "readDir" NONE "Directory stream is closed"
  263.       | readDir (ref (SOME dstr)) = readdir_ dstr;
  264.  
  265.     fun rewindDir (ref NONE) =
  266.     raiseSysML "rewindDir" NONE "Directory stream is closed"
  267.       | rewindDir (ref (SOME dstr)) = rewinddir_ dstr;
  268.  
  269.     fun closeDir (ref NONE) = ()
  270.       | closeDir (r as ref (SOME dstr)) = 
  271.     (r := NONE; closedir_ dstr);
  272. end;
  273.